home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / syncase.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  7.6 KB  |  248 lines
  1. ;;;;     Copyright (C) 1997, 2000, 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 2.1 of the License, or (at your option) any later version.
  7. ;;;; 
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;;; 
  17.  
  18.  
  19. (define-module (ice-9 syncase)
  20.   :use-module (ice-9 debug)
  21.   :use-module (ice-9 threads)
  22.   :export-syntax (sc-macro define-syntax define-syntax-public 
  23.                   eval-when fluid-let-syntax
  24.           identifier-syntax let-syntax
  25.           letrec-syntax syntax syntax-case  syntax-rules
  26.           with-syntax
  27.           include)
  28.   :export (sc-expand sc-expand3 install-global-transformer
  29.        syntax-dispatch syntax-error bound-identifier=?
  30.        datum->syntax-object free-identifier=?
  31.        generate-temporaries identifier? syntax-object->datum
  32.        void syncase)
  33.   :replace (eval))
  34.  
  35.  
  36.  
  37. (define expansion-eval-closure (make-fluid))
  38.  
  39. (define (env->eval-closure env)
  40.   (or (and env
  41.        (car (last-pair env)))
  42.       (module-eval-closure the-root-module)))
  43.  
  44. (define sc-macro
  45.   (procedure->memoizing-macro
  46.     (lambda (exp env)
  47.       (with-fluids ((expansion-eval-closure (env->eval-closure env)))
  48.         (sc-expand exp)))))
  49.  
  50. ;;; Exported variables
  51.  
  52. (define sc-expand #f)
  53. (define sc-expand3 #f)
  54. (define sc-chi #f)
  55. (define install-global-transformer #f)
  56. (define syntax-dispatch #f)
  57. (define syntax-error #f)
  58.  
  59. (define bound-identifier=? #f)
  60. (define datum->syntax-object #f)
  61. (define free-identifier=? #f)
  62. (define generate-temporaries #f)
  63. (define identifier? #f)
  64. (define syntax-object->datum #f)
  65.  
  66. (define primitive-syntax '(quote lambda letrec if set! begin define or
  67.                and let let* cond do quasiquote unquote
  68.                unquote-splicing case))
  69.  
  70. (for-each (lambda (symbol)
  71.         (set-symbol-property! symbol 'primitive-syntax #t))
  72.       primitive-syntax)
  73.  
  74. ;;; Hooks needed by the syntax-case macro package
  75.  
  76. (define (void) *unspecified*)
  77.  
  78. (define andmap
  79.   (lambda (f first . rest)
  80.     (or (null? first)
  81.         (if (null? rest)
  82.             (let andmap ((first first))
  83.               (let ((x (car first)) (first (cdr first)))
  84.                 (if (null? first)
  85.                     (f x)
  86.                     (and (f x) (andmap first)))))
  87.             (let andmap ((first first) (rest rest))
  88.               (let ((x (car first))
  89.                     (xr (map car rest))
  90.                     (first (cdr first))
  91.                     (rest (map cdr rest)))
  92.                 (if (null? first)
  93.                     (apply f (cons x xr))
  94.                     (and (apply f (cons x xr)) (andmap first rest)))))))))
  95.  
  96. (define (error who format-string why what)
  97.   (start-stack 'syncase-stack
  98.            (scm-error 'misc-error
  99.               who
  100.               "~A ~S"
  101.               (list why what)
  102.               '())))
  103.  
  104. (define the-syncase-module (current-module))
  105. (define the-syncase-eval-closure (module-eval-closure the-syncase-module))
  106.  
  107. (fluid-set! expansion-eval-closure the-syncase-eval-closure)
  108.  
  109. (define (putprop symbol key binding)
  110.   (let* ((eval-closure (fluid-ref expansion-eval-closure))
  111.      ;; Why not simply do (eval-closure symbol #t)?
  112.      ;; Answer: That would overwrite imported bindings
  113.      (v (or (eval-closure symbol #f) ;lookup
  114.         (eval-closure symbol #t) ;create it locally
  115.         )))
  116.     ;; Don't destroy Guile macros corresponding to
  117.     ;; primitive syntax when syncase boots.
  118.     (if (not (and (symbol-property symbol 'primitive-syntax)
  119.           (eq? eval-closure the-syncase-eval-closure)))
  120.     (variable-set! v sc-macro))
  121.     ;; Properties are tied to variable objects
  122.     (set-object-property! v key binding)))
  123.  
  124. (define (getprop symbol key)
  125.   (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
  126.     (and v
  127.      (or (object-property v key)
  128.          (and (variable-bound? v)
  129.           (macro? (variable-ref v))
  130.           (macro-transformer (variable-ref v)) ;non-primitive
  131.           guile-macro)))))
  132.  
  133. (define guile-macro
  134.   (cons 'external-macro
  135.     (lambda (e r w s)
  136.       (let ((e (syntax-object->datum e)))
  137.         (if (symbol? e)
  138.         ;; pass the expression through
  139.         e
  140.         (let* ((eval-closure (fluid-ref expansion-eval-closure))
  141.                (m (variable-ref (eval-closure (car e) #f))))
  142.           (if (eq? (macro-type m) 'syntax)
  143.               ;; pass the expression through
  144.               e
  145.               ;; perform Guile macro transform
  146.               (let ((e ((macro-transformer m)
  147.                 e
  148.                 (append r (list eval-closure)))))
  149.             (if (null? r)
  150.                 (sc-expand e)
  151.                 (sc-chi e r w))))))))))
  152.  
  153. (define generated-symbols (make-weak-key-hash-table 1019))
  154.  
  155. ;; We define our own gensym here because the Guile built-in one will
  156. ;; eventually produce uninterned and unreadable symbols (as needed for
  157. ;; safe macro expansions) and will the be inappropriate for dumping to
  158. ;; pssyntax.pp.
  159. ;;
  160. ;; syncase is supposed to only require that gensym produce unique
  161. ;; readable symbols, and they only need be unique with respect to
  162. ;; multiple calls to gensym, not globally unique.
  163. ;;
  164. (define gensym
  165.   (let ((counter 0))
  166.  
  167.     (define next-id
  168.       (if (provided? 'threads)
  169.           (let ((symlock (make-mutex)))
  170.             (lambda ()
  171.               (let ((result #f))
  172.                 (with-mutex symlock
  173.                   (set! result counter)
  174.                   (set! counter (+ counter 1)))
  175.                 result)))
  176.           ;; faster, non-threaded case.
  177.           (lambda ()
  178.             (let ((result counter))
  179.               (set! counter (+ counter 1))
  180.               result))))
  181.     
  182.     ;; actual gensym body code.
  183.     (lambda (. rest)
  184.       (let* ((next-val (next-id))
  185.              (valstr (number->string next-val)))
  186.           (cond
  187.            ((null? rest)
  188.             (string->symbol (string-append "syntmp-" valstr)))
  189.            ((null? (cdr rest))
  190.             (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
  191.            (else
  192.             (error
  193.              (string-append
  194.               "syncase's gensym expected 0 or 1 arguments, got "
  195.               (length rest)))))))))
  196.  
  197. ;;; Load the preprocessed code
  198.  
  199. (let ((old-debug #f)
  200.       (old-read #f))
  201.   (dynamic-wind (lambda ()
  202.           (set! old-debug (debug-options))
  203.           (set! old-read (read-options)))
  204.         (lambda ()
  205.           (debug-disable 'debug 'procnames)
  206.           (read-disable 'positions)
  207.           (load-from-path "ice-9/psyntax.pp"))
  208.         (lambda ()
  209.           (debug-options old-debug)
  210.           (read-options old-read))))
  211.  
  212.  
  213. ;;; The following lines are necessary only if we start making changes
  214. ;; (use-syntax sc-expand)
  215. ;; (load-from-path "ice-9/psyntax.ss")
  216.  
  217. (define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))
  218.  
  219. (define (eval x environment)
  220.   (internal-eval (if (and (pair? x)
  221.               (equal? (car x) "noexpand"))
  222.              (cadr x)
  223.              (sc-expand x))
  224.          environment))
  225.  
  226. ;;; Hack to make syncase macros work in the slib module
  227. (let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
  228.   (if m
  229.       (set-object-property! (module-local-variable m 'define)
  230.                 '*sc-expander*
  231.                 '(define))))
  232.  
  233. (define (syncase exp)
  234.   (with-fluids ((expansion-eval-closure
  235.          (module-eval-closure (current-module))))
  236.     (sc-expand exp)))
  237.  
  238. (set-module-transformer! the-syncase-module syncase)
  239.  
  240. (define-syntax define-syntax-public
  241.   (syntax-rules ()
  242.     ((_ name rules ...)
  243.      (begin
  244.        ;(eval-case ((load-toplevel) (export-syntax name)))
  245.        (define-syntax name rules ...)))))
  246.  
  247. (fluid-set! expansion-eval-closure (env->eval-closure #f))
  248.